home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / pars7.exe / PARS7.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-29  |  6.2 KB  |  327 lines
  1. unit pars7;
  2. {$O+,F+}
  3. interface
  4.  
  5. uses builder,pars7glb,realtype;
  6.  
  7. type
  8.  
  9. PParse = ^OParse;
  10.  
  11. OParse = object
  12.   fstring:string;
  13.   px,py,pt,pa,pb,pc,pd,pe: rpointer;
  14.   numop:integer;
  15.   fop:operationpointer;
  16.   constructor init(s:string; showprogress: boolean; var error:boolean);
  17.   procedure setparams(a,b,c,d,e:float);
  18.   procedure f(x,y,t:float;var r:float);
  19.   destructor done;
  20. end;
  21.  
  22. implementation
  23.  
  24. var lastop:operationpointer;
  25.  
  26.  
  27. procedure mynothing;
  28. begin
  29. end;
  30.  
  31. procedure mysum;
  32. begin
  33.   lastop^.dest^:=lastop^.arg1^+lastop^.arg2^;
  34. end;
  35.  
  36. procedure mydiff;
  37. begin
  38.   with lastop^ do
  39.      dest^:=arg1^-arg2^;
  40. end;
  41.  
  42. procedure myprod;
  43. begin
  44.   with lastop^ do
  45.      dest^:=arg1^*arg2^;
  46. end;
  47.  
  48. procedure mydivis;
  49. begin
  50.   with lastop^ do
  51.      dest^:=arg1^/arg2^;
  52. end;
  53.  
  54. procedure myminus;
  55. begin
  56.   with lastop^ do
  57.      dest^:=-arg1^;
  58. end;
  59.  
  60. procedure myintpower;
  61. var n,i:longint;
  62. begin
  63.   with lastop^ do
  64.   begin
  65.     n:=trunc(abs(arg2^))-1;
  66.     case n of
  67.     -1: dest^:=1;
  68.      0: dest^:=arg1^;
  69.     else
  70.     begin
  71.       dest^:=arg1^;
  72.       for i:=1 to n do
  73.        dest^:=dest^*arg1^;
  74.     end;
  75.    end;
  76.   if arg2^<0 then dest^:=1/dest^;
  77.  end;
  78. end;
  79.  
  80. procedure mysquare;
  81. begin
  82.   with lastop^ do
  83.     dest^:=sqr(arg1^);
  84. end;
  85.  
  86. procedure mythird;
  87. begin
  88.   with lastop^ do
  89.     dest^:=arg1^*arg1^*arg1^;
  90. end;
  91.  
  92. procedure myforth;
  93. begin
  94.   with lastop^ do
  95.     dest^:=sqr(sqr(arg1^));
  96. end;
  97.  
  98. procedure myrealpower;
  99. begin;
  100.   with lastop^ do
  101.     dest^:=exp(arg2^*ln(arg1^));
  102. end;
  103.  
  104. procedure mycos;
  105. begin
  106.   with lastop^ do
  107.     dest^:=cos(arg1^);
  108. end;
  109.  
  110. procedure mysin;
  111. begin
  112.   with lastop^ do
  113.     dest^:=sin(arg1^);
  114. end;
  115.  
  116. procedure myexp;
  117. begin
  118.   with lastop^ do
  119.     dest^:=exp(arg1^);
  120. end;
  121.  
  122. procedure myln;
  123. begin
  124.   with lastop^ do
  125.     dest^:=ln(arg1^);
  126. end;
  127.  
  128. procedure mysqrt;
  129. begin
  130.   with lastop^ do
  131.     dest^:=sqrt(arg1^);
  132. end;
  133.  
  134. procedure myarctan;
  135. begin
  136.   with lastop^ do
  137.     dest^:=arctan(arg1^);
  138. end;
  139.  
  140. procedure myabs;
  141. begin
  142.   with lastop^ do
  143.     dest^:=abs(arg1^);
  144. end;
  145.  
  146. procedure mymin;
  147. begin
  148.   with lastop^ do
  149.     if arg1^<arg2^ then dest^:=arg1^ else dest^:=arg2^;
  150. end;
  151.  
  152. procedure mymax;
  153. begin
  154.   with lastop^ do
  155.     if arg1^<arg2^ then dest^:=arg2^ else dest^:=arg1^;
  156. end;
  157.  
  158. procedure myheavi;
  159. begin
  160.   with lastop^ do
  161.     if arg1^<0 then dest^:=0 else dest^:=1;
  162. end;
  163.  
  164.  
  165. procedure myphase;
  166. var a:float;
  167. begin
  168.   with lastop^ do
  169.   begin
  170.     a:=arg1^/2/pi;
  171.     dest^:=2*pi*(a-round(a));
  172.   end;
  173. end;
  174.  
  175. procedure myrand;
  176. var j:word;
  177. begin
  178.   with lastop^ do
  179.   begin
  180.   j:=round(arg2^);
  181.   if j=randomresult then dest^:=1 else dest^:=0;
  182.   end;
  183. end;
  184.  
  185. procedure myarg;
  186. begin
  187.   with lastop^ do
  188.   if arg1^<0 then dest^:=arctan(arg2^/arg1^)+Pi else
  189.   if arg1^>0 then dest^:=arctan(arg2^/arg1^) else if arg2^>0
  190.   then dest^:=Pi/2 else dest^:=-Pi/2;
  191. end;
  192.  
  193. procedure mycosh;
  194. begin
  195.   with lastop^ do
  196.     dest^:=(exp(arg1^)+exp(-arg1^))/2;
  197. end;
  198.  
  199. procedure mysinh;
  200. begin
  201.   with lastop^ do
  202.     dest^:=(exp(arg1^)-exp(-arg1^))/2;
  203. end;
  204.  
  205. procedure myradius;
  206. begin
  207.   with lastop^ do
  208.     dest^:=sqrt(sqr(arg1^)+sqr(arg2^));
  209. end;
  210.  
  211. procedure myrandrand;
  212. begin
  213.   with lastop^ do
  214.   dest^:=arg1^+arg2^*contrandresult;
  215. end;
  216.  
  217.  
  218. {OParse}
  219.  
  220. constructor OParse.init(s:string; showprogress:boolean;var error:boolean);
  221. var i:integer; lop:operationpointer;
  222. begin
  223.     fstring:=s;
  224.     parsefunction(s,fop,px,py,pt,pa,pb,pc,pd,pe,numop,error,showprogress);
  225.     lop:=fop;
  226.     while lop<>nil do
  227.     begin
  228.       with lop^ do
  229.       begin
  230.         case opnum of
  231.           0,1,2: op:=mynothing;
  232.           3: op:=myminus;
  233.           4: op:=mysum;
  234.           5: op:=mydiff;
  235.           6: op:=myprod;
  236.           7: op:=mydivis;
  237.           8: op:=myintpower;
  238.           9: op:=myrealpower;
  239.           10:op:=mycos;
  240.           11:op:=mysin;
  241.           12:op:=myexp;
  242.           13:op:=myln;
  243.           14:op:=mysqrt;
  244.           15:op:=myarctan;
  245.           16:op:=mysquare;
  246.           17:op:=mythird;
  247.           18:op:=myforth;
  248.           19:op:=myabs;
  249.           20:op:=mymax;
  250.           21:op:=mymin;
  251.           22:op:=myheavi;
  252.           23:op:=myphase;
  253.           24:op:=myrand;
  254.           25:op:=myarg;
  255.           26:op:=mysinh;
  256.           27:op:=mycosh;
  257.           28:op:=myradius;
  258.           29:op:=myrandrand;
  259.         end; {case}
  260.       end; {with lop^}
  261.       lop:=lop^.next
  262.     end; {while lop<>nil}
  263. end;
  264.  
  265. procedure OParse.setparams;
  266. begin
  267.   pa^:=a; pb^:=b; pc^:=c; pd^:=d; pe^:=e;
  268. end;
  269.  
  270.  
  271. procedure OParse.f;
  272. begin
  273.     px^:=x; py^:=y; pt^:=t;
  274.     lastop:=fop;
  275.     while lastop^.next<>nil do
  276.     begin
  277.       lastop^.op;
  278.       lastop:=lastop^.next;
  279.     end;
  280.     lastop^.op;
  281.     r:=lastop^.dest^;
  282. end;
  283.  
  284. destructor OParse.done;
  285. var i,j:integer; lastop,nextop:operationpointer;
  286. begin
  287.   lastop:=fop;
  288.   while lastop<>nil do
  289.   begin
  290.     nextop:=lastop^.next;
  291.     while nextop<>nil do
  292.     begin
  293.           if nextop^.arg1 = lastop^.arg1 then nextop^.arg1:=nil;
  294.           if nextop^.arg2 = lastop^.arg1 then nextop^.arg2:=nil;
  295.           if nextop^.dest = lastop^.arg1 then nextop^.dest:=nil;
  296.           if nextop^.arg1 = lastop^.arg2 then nextop^.arg1:=nil;
  297.           if nextop^.arg2 = lastop^.arg2 then nextop^.arg2:=nil;
  298.           if nextop^.dest = lastop^.arg2 then nextop^.dest:=nil;
  299.           if nextop^.arg1 = lastop^.dest then nextop^.arg1:=nil;
  300.           if nextop^.arg2 = lastop^.dest then nextop^.arg2:=nil;
  301.           if nextop^.dest = lastop^.dest then nextop^.dest:=nil;
  302.           nextop:=nextop^.next;
  303.     end;
  304.     with lastop^ do
  305.     begin
  306.       if (arg1=px) or (arg1=py) or (arg1=pt) or (arg1=pa) or
  307.       (arg1=pb) or (arg1=pc) or (arg1=pd) or (arg1=pe) then arg1:=nil;
  308.       if (arg2=px) or (arg2=py) or (arg2=pt) or (arg2=pa) or
  309.       (arg2=pb) or (arg2=pc) or (arg2=pd) or (arg2=pe) then arg2:=nil;
  310.       if (dest=px) or (dest=py) or (dest=pt) or (dest=pa) or
  311.       (dest=pb) or (dest=pc) or (dest=pd) or (dest=pe) then dest:=nil;
  312.       if arg1<>nil then dispose(arg1);
  313.       if arg2<>nil then dispose(arg2);
  314.       if dest<>nil then dispose(dest);
  315.     end;
  316.     nextop:=lastop^.next;
  317.     dispose(lastop);
  318.     lastop:=nextop;
  319.   end;
  320.   dispose(px); dispose(py); dispose(pt);
  321.   dispose(pa); dispose(pb); dispose(pc);
  322.   dispose(pd); dispose(pe);
  323. end;
  324.  
  325.  
  326.  
  327. end.